home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / emacs_src_18_58.lha / emacs-18.58 / lisp / undigest.el < prev    next >
Lisp/Scheme  |  1992-02-21  |  4KB  |  105 lines
  1. ;; "RMAIL" mail reader for Emacs.
  2. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;; note Interent RFP934
  21.  
  22. (defun undigestify-rmail-message ()
  23.   "Break up a digest message into its constituent messages.
  24. Leaves original message, deleted, before the undigestified messages."
  25.   (interactive)
  26.   (widen)
  27.   (let ((buffer-read-only nil)
  28.     (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
  29.                       (rmail-msgend rmail-current-message))))
  30.     (goto-char (rmail-msgend rmail-current-message))
  31.     (narrow-to-region (point) (point))
  32.     (insert msg-string)
  33.     (narrow-to-region (point-min) (1- (point-max))))
  34.   (let ((error t)
  35.     (buffer-read-only nil))
  36.     (unwind-protect
  37.     (progn
  38.       (save-restriction
  39.         (goto-char (point-min))
  40.         (delete-region (point-min)
  41.                (progn (search-forward "\n*** EOOH ***\n")
  42.                   (point)))
  43.         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  44.         (narrow-to-region (point)
  45.                   (point-max))
  46.         (let* ((fill-prefix "")
  47.            (case-fold-search t)
  48.            (digest-name
  49.             (mail-strip-quoted-names
  50.              (or (save-restriction
  51.                (search-forward "\n\n")
  52.                (narrow-to-region (point-min) (point))
  53.                (goto-char (point-max))
  54.                (or (mail-fetch-field "Reply-To")
  55.                    (mail-fetch-field "To")
  56.                    (mail-fetch-field "Apparently-To")))
  57.              (error "Message is not a digest")))))
  58.           (save-excursion
  59.         (goto-char (point-max))
  60.         (skip-chars-backward " \t\n")
  61.         (let ((count 10) found)
  62.           ;; compensate for broken un*x digestifiers.  Sigh Sigh.
  63.           (while (and (> count 0) (not found))
  64.             (forward-line -1)
  65.             (setq count (1- count))
  66.             (if (looking-at (concat "End of.*Digest.*\n"
  67.                         (regexp-quote "*********") "*"
  68.                         "\\(\n------*\\)*"))
  69.             (setq found t)))
  70.           (if (not found) (error "Message is not a digest"))))
  71.           (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*"))
  72.           (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  73.           (save-restriction
  74.         (narrow-to-region (point)
  75.                   (progn (search-forward "\n\n")
  76.                      (point)))
  77.         (if (mail-fetch-field "To") nil
  78.           (goto-char (point-min))
  79.           (insert "To: " digest-name "\n")))
  80.           (while (re-search-forward
  81.               (concat "\n\n" (make-string 27 ?-) "-*\n*")
  82.               nil t)
  83.         (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
  84.         (save-restriction
  85.           (if (looking-at "End ")
  86.               (insert "To: " digest-name "\n\n")
  87.             (narrow-to-region (point)
  88.                       (progn (search-forward "\n\n"
  89.                                  nil 'move)
  90.                          (point))))
  91.           (if (mail-fetch-field "To") nil
  92.             (goto-char (point-min))
  93.             (insert "To: " digest-name "\n"))))))
  94.       (setq error nil)
  95.       (message "Message successfully undigestified")
  96.       (let ((n rmail-current-message))
  97.         (rmail-forget-messages)
  98.         (rmail-show-message n)
  99.         (rmail-delete-forward)))
  100.       (cond (error
  101.          (narrow-to-region (point-min) (1+ (point-max)))
  102.          (delete-region (point-min) (point-max))
  103.          (rmail-show-message rmail-current-message))))))
  104.  
  105.